perm filename SYSTEM.LSP[C,JRA] blob
sn#012875 filedate 1972-11-16 generic text, type T, neo UTF8
00100 (SETQ DEBUGLOOP NIL)
00200
00300 (*RSET T)
00600
00700 (PUTPROP 'DIFFERENCE (GET '*DIF 'SUBR) 'SUBR)
00800
00900 (PUTPROP 'SASSQ (GET 'SASSOC 'SUBR) 'SUBR)
01000
01100 (PUTPROP 'MAPC# (GET 'MAPC 'SUBR) 'SUBR)
01200
01300 (PUTPROP 'MAPCAR# (GET 'MAPCAR 'SUBR) 'SUBR)
01400
01500 (PUTPROP 'ASSQ (GET 'ASSOC 'SUBR) 'SUBR)
01600
01700 (PUTPROP 'APPLY# (GET 'APPLY 'LSUBR) 'LSUBR)
01800
01900
02000
02100 (SETQ PURE NIL)
02200
02300 (SETQ ERRLIST NIL)
02400 (SETQ EAR 0)
02500 (SETQ FRAMEVARS NIL)
02600 (SETQ CINTERRUPT NIL)
02700 (SETQ EXP NIL)
02800 (SETQ ALINK NIL)
02900 (SETQ FRAME* NIL)
03000 (SETQ BVARS NIL)
03100 (SETQ CLINK NIL)
03200 (SETQ *ITEMS NIL)
03300 (SETQ NUMACT 0.)
03400
03500 (DF PAGEBPORG (L) 'PAGEBPORG)
03600
03700 (DF GENPREFIX (L) 'GENPREFIX)
03800
00100 (DF DO (L)
00200 (PROG ($X $XI $XS $ET $BD)
00300 (*SQ $X (CAR L))
00400 (*SQ $XI (CADR L))
00500 (*SQ $XS (CADDR L))
00600 (*SQ $ET (CADDDR L))
00700 (*SQ $BD (CDDDDR L))
00800 START
00900 (SET $X $XI)
01000 DOLOOP
01100 (COND ((EVAL $ET)(RETURN NIL)))
01200 (MAPC 'EVAL $BD)
01300 (SET $X (EVAL $XS))
01400 (GO DOLOOP) ))
01500
01600
00100 (PUTPROP 'LIST# (GET 'LIST 'FSUBR) 'FSUBR)
00200
00300 (DEFPROP LIST
00400 (LAMBDA $N
00500 ((LABEL LIST1 (LAMBDA ($X)
00600 (COND ((EQUAL $X (ADD1 $N)) NIL)
00700 (T (CONS (ARG $X)(LIST1 (ADD1 $X)))))))
00800 1))
00900 EXPR)
01000
01100 (REMPROP 'LIST 'FSUBR)
01200
01300 (DE ASSOC ($A $L)
01400 (COND ((NULL $L) NIL)
01500 ((EQUAL $A (CAAR $L))(CAR $L))
01600 (T (ASSOC $A (CDR $L)))))
01700
01800 (DEFPROP MIN (LAMBDA $N
01900 (PROG ($V)
02000 (SETQ $V (ARG $N))
02100 A (SETQ $N (SUB1 $N))
02200 (COND ((ZEROP $N)(RETURN $V))
02300 ((LESSP (ARG $N) $V) (SETQ $V (ARG $N))))
02400 (GO A)))EXPR)
02500
02600 (DEFPROP MAX (LAMBDA $N
02700 (PROG ($V)
02800 (SETQ $V (ARG $N))
02900 A (SETQ $N (SUB1 $N))
03000 (COND ((ZEROP $N)(RETURN $V))
03100 ((GREATERP (ARG $N) $V)(SETQ $V (ARG $N))))
03200 (GO A)))EXPR)
03300
03400 (DEFPROP MEMQ (LAMBDA ($E $L)
03500 (COND ((NULL $L) NIL)
03600 ((NOT (ATOM (CAR $L)))(MEMQ $E (CDR $L)))
03700 ((EQ $E (CAR $L)) $L)
03800 (T (MEMQ $E (CDR $L)))))EXPR)
03900
04000 (DEFPROP MEMBER (LAMBDA ($E $L)
04100 (COND ((NULL $L) NIL)
04200 ((EQUAL $E (CAR $L)) $L)
04300 (T (MEMBER $E (CDR $L)))))EXPR)
04400
04500 (DEFPROP RANDOM (LAMBDA ()
04600 (QUOTIENT (TIMES (EXAMINE 15)(EXAMINE 16) ) (MAX (EXAMINE 15)(EXAMINE 16)))
04700 )EXPR)
04800
04900
00100 (DEFPROP AND (LAMBDA ($L)
00200 (AND# (CDR $L))) MACRO)
00300
00400 (DEFPROP AND# (LAMBDA ($L)
00500 (COND ((NULL (CDR $L))(LIST (QUOTE COND)(LIST (CAR $L))))
00600 (T (LIST (QUOTE COND)(LIST (CAR $L)(AND# (CDR $L)))))))EXPR)
00700
00800 (DEFPROP OR (LAMBDA ($L)
00900 (OR# (CDR $L)))
01000 MACRO)
01100
01200 (DEFPROP OR# (LAMBDA ($L)
01300 (APPEND (QUOTE (COND))(MAPCAR (FUNCTION LIST) $L)))
01400 EXPR)
01500
01600 (PUTPROP 'AND '(LAMBDA ($L)
01700 (AND# (CDR $L))) 'MACRO)
01800
01900 (PUTPROP 'OR '(LAMBDA ($L)
02000 (OR# (CDR $L)))
02100 'MACRO)
02200
02300 (DEFPROP MAPCAR (LAMBDA $L
02400 (COND ((GREATERP $L 3)(PRINT '(MAPCAR OF 3 ARG LISTS))(ERR))
02500 ((EQUAL $L 2)(MAPCAR# (ARG 1)(ARG 2)))
02600 (T (COND ((OR (NULL (ARG 2))(NULL (ARG 3)))NIL)
02700 (T (CONS ((ARG 1)(CAR (ARG 2))(CAR (ARG 3)))
02800 (MAPCAR (ARG 1)(CDR (ARG 2))(CDR (ARG 3)))))))))EXPR)
02900
03000 (DEFPROP MAPC (LAMBDA $L
03100 (COND ((GREATERP $L 4)(PRINT '(MAPC OF FOUR ARG LISTS))(ERR))
03200 ((EQUAL $L 2)(MAPC# (ARG 1)(ARG 2)) (ARG 2) )
03300 ((EQUAL $L 3)
03400 (PROG ($A $B)
03500 (SETQ $A (ARG 2))(SETQ $B (ARG 3))
03600 L1 (AND (OR (NULL $A)(NULL $B))(RETURN (ARG 2)) )
03700 ((ARG 1)(CAR $A)(CAR $B))
03800 (SETQ $A (CDR $A))(SETQ $B (CDR $B))
03900 (GO L1 )))
04000 (T (PROG ($A $B $C) (SETQ $A (ARG 2))(SETQ $B (ARG 3))(SETQ $C(ARG 4))
04100 L1 (AND (OR (NULL $A)(NULL $B)(NULL $C))(RETURN (ARG 2)))
04200 ((ARG 1)(CAR $A)(CAR $B)(CAR $C))
04300 (SETQ $A(CDR $A))(SETQ $B (CDR $B))(SETQ $C(CDR $C))
04400 (GO L1)))))EXPR)
04500
04600 (DECLARE (SPECIAL $R $F $L))
04700
04800 (DEFPROP MAPCAN
04900 (LAMBDA($F $L)
05000 (PROG ($R)
05100 (MAPC(FUNCTION (LAMBDA($X)(SETQ $R(NCONC $R ($F $X)))))$L)
05200 (RETURN $R)))
05300 EXPR)
05400
05500 (DECLARE (UNSPECIAL $R $F $L))
05600
05700
05800
05900 (DEFPROP APPLY
06000 (LAMBDA $L
06100 (COND ((GETL (ARG 1) (QUOTE (EXPR LSUBR SUBR)))
06200 (APPLY# (ARG 1)(ARG 2)))
06300 ((EVAL (CONS (ARG 1)(ARG 2))))))
06400 EXPR)
06500
06600 (DM PP ($L) (LIST 'GRINDEF (EVAL (CADR $L))))
06700
00100
00200
00300 (PUTPROP '/= (GET 'EQUAL 'SUBR) 'SUBR)
00400 (PUTPROP '/< (GET '*LESS 'SUBR) 'SUBR)
00500 (PUTPROP '/> (GET '*GREAT 'SUBR) 'SUBR)
00600 (PUTPROP '/+ (GET '*PLUS 'SUBR) 'SUBR)
00700 (PUTPROP '/- (GET '*DIF 'SUBR) 'SUBR)
00800 (PUTPROP '// (GET '*QUO 'SUBR) 'SUBR)
00900 (PUTPROP '/* (GET 'TIMES 'SUBR) 'SUBR)
01000
01100 (PUTPROP '/1+ (GET 'ADD1 'SUBR) 'SUBR)
01200 (PUTPROP '/1- (GET 'SUB1 'SUBR) 'SUBR)
01300
01400 (DF MAKREADTABLE (L) (APPEND '(MAKREADTABLE) L))
01500 (DF SSTATUS (L) (APPEND '(SSTATUS) L))
01600
01700 (DE BOUNDP (L) (GET L 'VALUE))
01800
01900 (PUTPROP '*SQ (GET 'SETQ 'FSUBR) 'FSUBR)
02000
02100 (DF SETQ ($#%L)
02200 (PROG ($#%X)
02300 A (COND ((NULL $#%L)(RETURN $#%X)))
02400 (*SQ $#%X (SET (EVAL '(CAR $#%L))(EVAL (CADR $#%L)) ))
02500 (*SQ $#%L (CDDR $#%L))
02600 (GO A)))
02700
02800 (PUTPROP '*GT (GET 'GET 'SUBR) 'SUBR)
02900 (DE GET ($X $I)(COND ((NUMBERP $X)NIL)(T(*GT $X $I))))
03000
00100
00200
00300 (DEFPROP CATCH
00400 (LAMBDA(L)
00500 (PROG (Z)
00600 (SETQ Z (EVAL (LIST (QUOTE ERRSET) (CAR L) NIL)))
00700 (COND ((ATOM Z) (RETURN Z)) (T (RETURN (CAR Z))))))
00800 FEXPR)
00900
01000 (DEFPROP THROW
01100 (LAMBDA (L) (ERR L))
01200 EXPR)
00100
00200 (DF DELETE (%N)(PROG(%NN %X %Y %Z)
00300 (SETQ %NN(COND((EQ(LENGTH %N)3)(EVAL(CADDR %N)))(T -1)))
00400 (SETQ %X(EVAL(CAR %N)))(SETQ %Z(SETQ %Y(GET(CADR %N)'VALUE)))
00500 A(COND((OR(ZEROP %NN)(NULL (CDR %Y)))(RETURN(CDR %Z)))
00600 ((EQUAL %X (CADR %Y))(RPLACD %Y(CDDR %Y))(SETQ %NN(SUB1 %NN))(GO A))
00700 )(SETQ %Y(CDR %Y)) (GO A) ))
00100 (DF DELQ (%N)(PROG(%NN %X %Y %Z)
00200 (SETQ %NN(COND((EQ(LENGTH %N)3)(EVAL(CADDR %N)))(T -1)))
00300 (SETQ %X(EVAL(CAR %N)))(SETQ %Z(SETQ %Y(GET(CADR %N)'VALUE)))
00400 A(COND((OR(ZEROP %NN)(NULL (CDR %Y)))(RETURN(CDR %Z)))
00500 ((EQ %X (CADR %Y))(RPLACD %Y(CDDR %Y))(SETQ %NN(SUB1 %NN))(GO A))
00600 )(SETQ %Y(CDR %Y)) (GO A) ))
00700 (DE CONIVINIT()(PROG NIL(CONIVE)(DATA-INIT)(START)))
00800